home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / lesfac.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  9.7 KB  |  306 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module lesfac)
  13.  
  14. (DECLARE-top (GENPREFIX LSF)
  15.      (SPECIAL *FNEWVARSW FACLIST RES POLY*))
  16.  
  17. (LOAD-MACSYMA-MACROS RZMAC RATMAC)
  18.  
  19. (DEFUN NEWSYM2 (P E &AUX (G (GENSYM)))
  20.   (PUTPROP G E 'DISREP)
  21.   (VALPUT G (SUB1 (VALGET (CAR GENVAR))))
  22.   (SETQ GENVAR (CONS G GENVAR))
  23.   (SETQ VARLIST (CONS E VARLIST))
  24.   (PUTPROP G P 'UNHACKED)
  25.   G) 
  26.  
  27. (DEFUN GETUNHACK (GEN) (OR (GET GEN 'UNHACKED) (PGET GEN))) 
  28.  
  29. (DEFMACRO GETDIS (X) `(GET ,X 'DISREP))
  30. (DEFMACRO CONS1 (X) `(CONS ,X 1))
  31.  
  32. (DEFUN FRPOLY? (R) (EQUAL 1 (CDR R)))
  33.  
  34. (defmacro setcall (&rest l)
  35.   (setq l (cons 'setcall l))
  36.        (SUBLIS (LIST (CONS 'FNCALL (CDR L))
  37.              (CONS 'A (CADDR L))
  38.              (CONS 'B (CADDDR L)))
  39.            '(PROG1 (CAR (SETQ A FNCALL)) (SETQ B (CADDR A) A (CADR A)))))
  40.  
  41. (DEFUN PQUOCOF (P Q) 
  42.        ((LAMBDA (QQ) (COND (QQ (LIST Q QQ 1.)) ((LIST 1. P Q))))
  43.     (TESTDIVIDE P Q))) 
  44.  
  45. (DEFUN POLYST (A) 
  46.        (COND ((PCOEFP A) (LIST A))
  47.          (T (CONS (CONS (CAR A) (CADR A)) (POLYST (CADDR A)))))) 
  48.  
  49. (DEFUN CDINF (A B BOTH) 
  50.        (COND ((OR (PCOEFP A) (PCOEFP B)) (LIST 1. A B))
  51.          (T (SETQ A (NCONS (COPY A))
  52.               B (NCONS (COND (BOTH (COPY B))(T B))))
  53.         (LIST (CD1 A B BOTH) (CAR A) (CAR B))))) 
  54.  
  55. (DEFUN CD1 (A B BOTH) 
  56.        (COND ((OR (PCOEFP (CAR A)) (PCOEFP (CAR B))) 1.)
  57.          ((EQ (CAAR A) (CAAR B))
  58.           (PTIMES (PEXPT (PGET (CAAR A))        ;CHECK FOR ALG. TRUNC.
  59.             (PROG1 (COND (BOTH (f+ (CADAR A) (CADAR B))) (T (CADAR A)))
  60.                (RPLACA A (CADDAR A))
  61.                (COND (BOTH (RPLACA B (CADDAR B)))
  62.                  (T (SETQ B (CDDAR B))))))
  63.             (CD1 A B BOTH)))
  64.          ((POINTERGP (CAAR A) (CAAR B)) (CD1 (CDDAR A) B BOTH))
  65.          (T (CD1 A (CDDAR B) BOTH)))) 
  66.  
  67. (DEFUN LMAKE (P L) 
  68.        (COND ((PCOEFP P) (CONS P L))
  69.          ((GET (CAR P) 'UNHACKED)
  70.           (LMAKE (CADDR P) (CONS (CONS (CAR P) (CADR P)) L)))
  71.          (T (SETQ L (LMAKE (CADDR P) L))
  72.         (RPLACA L (LIST (CAR P) (CADR P) (CAR L))))))
  73.  
  74. (DEFUN LMAKE2 (P L)
  75.        (SETQ L (LMAKE P L))
  76.        (MAPC (FUNCTION (LAMBDA (X) (RPLACA X (GETUNHACK (CAR X)))))
  77.          (CDR L))
  78.        (cond ((equal (car l) 1) (cdr l))
  79.          (t (RPLACA L (CONS (CAR L) 1)))))
  80.  
  81.  
  82. (DEFUN PMAKE (L) 
  83.        (COND ((NULL L) 1.)
  84.          ((= 0. (CDAR L)) (PMAKE (CDR L)))
  85.          ((NUMBERP (CAAR L))    ;CLAUSE SHOULD BE ELIMINATED ASAP
  86.           (PTIMES (CEXPT (CAAR L) (CDAR L)) (PMAKE (CDR L))))
  87.          (T (PTIMES (LIST (CAAR L) (CDAR L) 1.) (PMAKE (CDR L)))))) 
  88.  
  89. (DEFUN FACMGCD (PL)            ;GCD OF POLY LIST FOR EZGCD WITH RATFAC
  90.        (DO ((L (CDR PL) (CDR L))
  91.         (ANS NIL (CONS (CADDR GCD) ANS))
  92.         (GCD (CAR PL) (CAR GCD)))
  93.        ((NULL L) (CONS GCD (NREVERSE ANS)))
  94.        (SETQ GCD (FPGCDCO GCD (CAR L)))
  95.        (COND ((EQUAL (CAR GCD) 1) (RETURN (CONS 1 PL)))
  96.          ((NULL ANS) (SETQ ANS (LIST (CADR GCD))))
  97.          ((NOT (EQUAL (CADR GCD) 1))
  98.           (DO ((L2 ANS (CDR L2))) ((NULL L2))
  99.               (RPLACA L2 (PTIMES (CADR GCD) (CAR L2))))))))
  100.                  
  101.  
  102. (DEFUN FPGCDCO (P Q) ((LAMBDA ($RATFAC GCDL)    ;FACTORED PGCDCOFACTS
  103.        (COND ((OR (PCOEFP P) (PCOEFP Q)) (PGCDCOFACTS P Q))
  104.          (T (LIST (PTIMESCHK 
  105.                (SETCALL PGCDCOFACTS P Q)
  106.                (CAR (SETQ P (LMAKE P NIL)
  107.                   Q (LMAKE Q NIL)
  108.                   GCDL (MAPCAR 'PMAKE (LGCD1 (CDR P) (CDR Q)) ))))
  109.               (PTIMESCHK (CAR P) (CADR GCDL))
  110.               (PTIMESCHK (CAR Q) (CADDR GCDL))))))
  111.               NIL NIL) ) 
  112.  
  113. ;;    NOTE: ITEMS ON VARLIST ARE POS. NORMAL
  114. ;;    INTEGER COEF GCD=1 AND LEADCOEF. IS POS.
  115.  
  116. (DEFUN LGCD1 (A B) 
  117.        (PROG (PTLIST G BJ C T1 D1 D2) 
  118.          (SETQ PTLIST (MAPCAR #'(LAMBDA (X)
  119.                        X ;Ignored.
  120.                        B) A))
  121.          (DO ((A A (CDR A)) (PTLIST PTLIST (CDR PTLIST)))
  122.          ((NULL A))
  123.          (DO ((AI (GETUNHACK (CAAR A)))
  124.               (B (CAR PTLIST) (CDR B)))
  125.              ((NULL B))
  126.              (AND (ZEROP (CDAR B)) (GO NEXTB))
  127.              (SETQ D1 1 D2 1)
  128.              (SETQ BJ (GETUNHACK (CAAR B)))
  129.              (SETQ C (COND ((PIRREDP (CAAR A))
  130.                     (COND ((PIRREDP (CAAR B)) 1.)
  131.                       (T (SETCALL PQUOCOF BJ AI))))
  132.                    ((PIRREDP (CAAR B)) (SETCALL PQUOCOF AI BJ))
  133.                    (T (SETCALL PGCDCOFACTS AI BJ))))
  134.              (COND ((EQUAL C 1.) (GO NEXTB))
  135.                ((EQUAL AI 1) (GO BLOOP)))
  136.              ALOOP
  137.              (COND ((SETQ T1 (TESTDIVIDE AI C))
  138.                 (SETQ AI T1 D1 (f1+ D1))
  139.                 (GO ALOOP)))
  140.              BLOOP
  141.              (AND (= D1 1.)
  142.               (NOT (EQUAL BJ 1))
  143.               (DO ((T1
  144.                   (TESTDIVIDE BJ C)
  145.                   (TESTDIVIDE BJ C)))
  146.                   ((NULL T1))
  147.                   (SETQ BJ T1 D2 (f1+ D2))))
  148.              (SETQ G (CONS (CONS (MAKPRODG C T)
  149.                      (MIN (SETQ D1 (f* D1 (CDAR A)))
  150.                           (SETQ D2 (f* D2 (CDAR B)))))
  151.                    G))
  152.              (COND ((> D1 (CDAR G))
  153.                 (RPLACD (LAST A)
  154.                     (NCONS (CONS (CAAR G) (f- D1 (CDAR G)))))
  155.                 (RPLACD (LAST PTLIST) (NCONS (CDR B)))))
  156.              (COND ((> D2 (CDAR G))
  157.                 (RPLACD (LAST B)
  158.                     (NCONS (CONS (CAAR G) (f- D2 (CDAR G)))))))
  159.              (RPLACA (CAR A) (MAKPRODG AI T))
  160.              (RPLACA (CAR B) (MAKPRODG BJ T))
  161.              (AND (EQUAL BJ 1) (RPLACD (CAR B) 0))
  162.              (AND (EQUAL AI 1.) (RPLACD (CAR A) 0) (RETURN NIL))
  163.              NEXTB))
  164.          (RETURN (LIST G A B)))) 
  165.  
  166. (DEFUN MAKPRODG (P SW)
  167.     (COND ((PCOEFP P) P)
  168.         (T (CAR (MAKPROD P SW)))))
  169.  
  170.  
  171.  
  172.  
  173. (DEFUN DOPGCDCOFACTS (X Y)
  174.        (let (($GCD
  175.     $GCD)( $RATFAC NIL)) (OR (MEMQ $GCD *GCDL*) (SETQ $GCD '$EZ))
  176.         (PGCDCOFACTS X Y)))
  177.  
  178. (DEFUN FACRPLUS (X Y) 
  179.        ((LAMBDA (A B C D)
  180.         (SETQ X (SETCALL DOPGCDCOFACTS A C) 
  181.               Y (SETCALL FPGCDCO B D))
  182.         (SETQ A (MAKPROD
  183.              (PPLUS (PFLATTEN (PTIMESCHK A D))
  184.                 (PFLATTEN (PTIMESCHK B C))) NIL))
  185.         (SETQ B (PTIMESCHK B D))
  186.         (COND ($ALGEBRAIC (SETQ Y (PTIMESCHK Y B))
  187.                   (SETCALL FPGCDCO Y A) ;for unexpected gcd
  188.                   (CONS (PTIMES X A) Y))
  189.               (T (SETQ C (SETCALL CDINF Y B NIL))
  190.              (SETCALL FPGCDCO Y A)
  191.              (CONS (PTIMES X A) (PTIMESCHK Y (PTIMESCHK C B))))))
  192.     (CAR X)
  193.     (CDR X)
  194.     (CAR Y)
  195.     (CDR Y)))
  196.  
  197. (DEFUN MFACPPLUS (L)
  198.        (let (($gcd
  199.     (or $gcd '$ez))( $ratfac nil)( g nil))
  200.         (setq g (OLDCONTENT2 (SORT (COPY1 L) 'CONTODR) 0))
  201.         (COND ((PZEROP G) G)
  202.               ((DO ((A (PFLATTEN (PQUOTIENT (CAR L) G))
  203.                    (PPLUS A (PFLATTEN (PQUOTIENT (CAR LL) G))))
  204.                 (LL (CDR L) (CDR LL)))
  205.                ((NULL LL) (PTIMES G (MAKPROD A NIL))))))))
  206.  
  207. ;; no longer called
  208. ;;(DEFUN FACPPLUS (P Q)
  209. ;;    (PTIMES (SETCALL DOPGCDCOFACTS P Q)
  210. ;;        (MAKPROD (PPLUS (PFLATTEN P) (PFLATTEN Q)) NIL)))
  211.  
  212. (DEFUN  FACRTIMES (X Y GCDSW) 
  213.        (COND ((NOT GCDSW)
  214.           (CONS (PTIMES (CAR X) (CAR Y)) (PTIMESCHK (CDR X) (CDR Y))))
  215.          (T (let ((G
  216.          (CDINF (CAR X) (CAR Y) T))( H
  217.          (CDINF (CDR X) (CDR Y) T))) (SETQ X (FPGCDCO (CADR G) (CADDR H)))
  218.                    (SETQ Y (FPGCDCO (CADDR G) (CADR H)))
  219.                    (CONS (PTIMES (CAR G) (PTIMES (CADR X) (CADR Y)))
  220.                      (PTIMESCHK (CAR H) (PTIMESCHK (CADDR X) (CADDR Y))))))))
  221.  
  222. (DEFUN PFACPROD (POLY)             ;FOR RAT3D
  223.        (COND ((PCOEFP POLY) (CFACTOR POLY))
  224.          (T (NCONC (PFACPROD (CADDR POLY))
  225.                (LIST (PGET (CAR POLY)) (CADR POLY))))))
  226.  
  227. (DEFUN FPCONTENT (POLY)
  228.        (let (($ratfac
  229.     nil))                ;algebraic uses
  230.        (SETQ POLY (OLDCONTENT POLY))            ;rattimes?
  231.        ((lambda (a)                    ;main var. content
  232.         (cond ((> a 0) (setq a (list (CAADR POLY) A 1))
  233.                        (SETQ POLY
  234.                      (LIST (PTIMES (CAR POLY) A)
  235.                        (PQUOTIENT (CADR POLY) A))))))
  236.     (LOWDEG (CDADR POLY)))
  237.        (COND ((PMINUSP (CADR POLY))
  238.           (LIST (PMINUS (CAR POLY)) (PMINUS (CADR POLY))))
  239.          (T POLY))))
  240.  
  241. ;; LOWDEG written to compute the lowest degree of a polynomial. - RZ
  242.  
  243. (DEFMFUN LOWDEG (P)
  244.   (DO ((L P (CDDR L))) ((NULL (CDDR L)) (CAR L))))
  245.  
  246. (DEFUN MAKPROD (POLY CONTSWITCH) 
  247.        (COND ((PUREPROD POLY) POLY)
  248.          ((NULL (CDDDR POLY))
  249.           (PTIMES (LIST (CAR POLY) (CADR POLY) 1)
  250.               (MAKPROD (CADDR POLY) CONTSWITCH)))
  251.          (CONTSWITCH (MAKPROD1 POLY))
  252.          (T (SETQ POLY (FPCONTENT POLY))
  253.         (PTIMES (MAKPROD (CAR POLY) CONTSWITCH) (MAKPROD1 (CADR POLY)))))) 
  254.  
  255. (DEFUN MAKPROD1 (POLY*) 
  256.        (DO ((V VARLIST (CDR V))
  257.         (G GENVAR (CDR G))
  258.         (P (PDIS POLY*))
  259.         (RES 1.))
  260.        ((NULL V) (MAKSYMP POLY*))
  261.        (AND (ALIKE1 P (CAR V)) (RETURN (PGET (CAR G)))))) 
  262.  
  263. (DEFUN MAKSYM (P) (NEWSYM2 P (PDIS P))) 
  264.  
  265. (DEFUN MAKSYMP (P) (COND ((ATOM P) P) (T (PGET (MAKSYM P))))) 
  266.  
  267. (DEFUN PFLATTEN (H) 
  268.        (PROG (M) 
  269.          (SETQ M (LISTOVARS H))
  270.     CHECKMORE
  271.          (COND ((NULL M) (RETURN H))
  272.            ((NOT ((LAMBDA (P) (OR (NULL P) (EQ (CAR M) (CAR P))))
  273.               (GETUNHACK (CAR M))))
  274.             (GO REDO))
  275.            (T (SETQ M (CDR M)) (GO CHECKMORE)))
  276.     REDO (RETURN (let ($ratfac) (PFLAT1 H))))) 
  277.  
  278. (DEFUN PFLAT1 (P) 
  279.        (COND ((PCOEFP P) P)
  280.          ((NULL (CDDDR P))
  281.           (PTIMES (PEXPT (GETUNHACK (CAR P)) (CADR P)) (PFLAT1 (CADDR P))))
  282.          (T (DO ((VAL (GETUNHACK (CAR P)))
  283.              (LD (CADR P) (CAR A))
  284.              (A (CDDDR P) (CDDR A))
  285.              (ANS (PFLAT1 (CADDR P))))
  286.             ((NULL A) (PTIMES ANS (PEXPT VAL LD)))
  287.             (SETQ ANS
  288.               (PPLUS (PTIMES ANS
  289.                      (PEXPT VAL (f- LD (CAR A))))
  290.                  (PFLAT1 (CADR A))))))))
  291.  
  292. (DEFUN PIRREDP (X) 
  293.        (AND (SETQ X (GETDIS X))
  294.         (OR (ATOM X) (MEMQ 'IRREDUCIBLE (CDAR X)))))
  295.  
  296. (DEFUN KNOWNFACTORS (D) 
  297.        (PROG (H) 
  298.          (COND ((PCOEFP D) (RETURN D)))
  299.          (SETQ H (GETDIS (CAR D)))
  300.          (RETURN (COND ((OR (ATOM H) (NOT (EQ (CAAR H) 'MTIMES)))
  301.                 (PTIMES (KNOWNFACTORS (CADDR D))
  302.                     (LIST (CAR D) (CADR D) 1.)))
  303.                (T (SETQ H (GETUNHACK (CAR D)))
  304.                   (PTIMES (KNOWNFACTORS (CADDR D))
  305.                       (PEXPT (KNOWNFACTORS H) (CADR D)))))))) 
  306.